home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xlisp_21.zoo / xldmem.c < prev    next >
C/C++ Source or Header  |  1990-02-28  |  15KB  |  694 lines
  1. /* xldmem - xlisp dynamic memory management routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* node flags */
  9. #define MARK    1
  10. #define LEFT    2
  11.  
  12. /* macro to compute the size of a segment */
  13. #define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
  14.  
  15. /* external variables */
  16. extern LVAL obarray,s_gcflag,s_gchook,s_unbound,true;
  17. extern LVAL xlenv,xlfenv,xldenv;
  18. extern char buf[];
  19.  
  20. /* variables local to xldmem.c and xlimage.c */
  21. SEGMENT *segs,*lastseg,*fixseg,*charseg;
  22. int anodes,nsegs,gccalls;
  23. long nnodes,nfree,total;
  24. LVAL fnodes;
  25.  
  26. /* external procedures */
  27. extern char *malloc();
  28. extern char *calloc();
  29.  
  30. /* forward declarations */
  31. FORWARD LVAL newnode();
  32. FORWARD unsigned char *stralloc();
  33. FORWARD SEGMENT *newsegment();
  34.  
  35. /* cons - construct a new cons node */
  36. LVAL cons(x,y)
  37.   LVAL x,y;
  38. {
  39.     LVAL nnode;
  40.  
  41.     /* get a free node */
  42.     if ((nnode = fnodes) == NIL) {
  43.     xlstkcheck(2);
  44.     xlprotect(x);
  45.     xlprotect(y);
  46.     findmem();
  47.     if ((nnode = fnodes) == NIL)
  48.         xlabort("insufficient node space");
  49.     xlpop();
  50.     xlpop();
  51.     }
  52.  
  53.     /* unlink the node from the free list */
  54.     fnodes = cdr(nnode);
  55.     --nfree;
  56.  
  57.     /* initialize the new node */
  58.     nnode->n_type = CONS;
  59.     rplaca(nnode,x);
  60.     rplacd(nnode,y);
  61.  
  62.     /* return the new node */
  63.     return (nnode);
  64. }
  65.  
  66. /* cvstring - convert a string to a string node */
  67. LVAL cvstring(str)
  68.   char *str;
  69. {
  70.     LVAL val;
  71.     xlsave1(val);
  72.     val = newnode(STRING);
  73.     val->n_strlen = strlen(str) + 1;
  74.     val->n_string = stralloc(getslength(val));
  75.     strcpy(getstring(val),str);
  76.     xlpop();
  77.     return (val);
  78. }
  79.  
  80. /* newstring - allocate and initialize a new string */
  81. LVAL newstring(size)
  82.   int size;
  83. {
  84.     LVAL val;
  85.     xlsave1(val);
  86.     val = newnode(STRING);
  87.     val->n_strlen = size;
  88.     val->n_string = stralloc(getslength(val));
  89.     strcpy(getstring(val),"");
  90.     xlpop();
  91.     return (val);
  92. }
  93.  
  94. /* cvsymbol - convert a string to a symbol */
  95. LVAL cvsymbol(pname)
  96.   char *pname;
  97. {
  98.     LVAL val;
  99.     xlsave1(val);
  100.     val = newvector(SYMSIZE);
  101.     val->n_type = SYMBOL;
  102.     setvalue(val,s_unbound);
  103.     setfunction(val,s_unbound);
  104.     setpname(val,cvstring(pname));
  105.     xlpop();
  106.     return (val);
  107. }
  108.  
  109. /* cvsubr - convert a function to a subr or fsubr */
  110. LVAL cvsubr(fcn,type,offset)
  111.   LVAL (*fcn)(); int type,offset;
  112. {
  113.     LVAL val;
  114.     val = newnode(type);
  115.     val->n_subr = fcn;
  116.     val->n_offset = offset;
  117.     return (val);
  118. }
  119.  
  120. /* cvfile - convert a file pointer to a stream */
  121. LVAL cvfile(fp)
  122.   FILE *fp;
  123. {
  124.     LVAL val;
  125.     val = newnode(STREAM);
  126.     setfile(val,fp);
  127.     setsavech(val,'\0');
  128.     return (val);
  129. }
  130.  
  131. /* cvfixnum - convert an integer to a fixnum node */
  132. LVAL cvfixnum(n)
  133.   FIXTYPE n;
  134. {
  135.     LVAL val;
  136.     if (n >= SFIXMIN && n <= SFIXMAX)
  137.     return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
  138.     val = newnode(FIXNUM);
  139.     val->n_fixnum = n;
  140.     return (val);
  141. }
  142.  
  143. /* cvflonum - convert a floating point number to a flonum node */
  144. LVAL cvflonum(n)
  145.   FLOTYPE n;
  146. {
  147.     LVAL val;
  148.     val = newnode(FLONUM);
  149.     val->n_flonum = n;
  150.     return (val);
  151. }
  152.  
  153. /* cvchar - convert an integer to a character node */
  154. LVAL cvchar(n)
  155.   int n;
  156. {
  157.     if (n >= CHARMIN && n <= CHARMAX)
  158.     return (&charseg->sg_nodes[n-CHARMIN]);
  159.     xlerror("character code out of range",cvfixnum((FIXTYPE)n));
  160. }
  161.  
  162. /* newustream - create a new unnamed stream */
  163. LVAL newustream()
  164. {
  165.     LVAL val;
  166.     val = newnode(USTREAM);
  167.     sethead(val,NIL);
  168.     settail(val,NIL);
  169.     return (val);
  170. }
  171.  
  172. /* newobject - allocate and initialize a new object */
  173. LVAL newobject(cls,size)
  174.   LVAL cls; int size;
  175. {
  176.     LVAL val;
  177.     val = newvector(size+1);
  178.     val->n_type = OBJECT;
  179.     setelement(val,0,cls);
  180.     return (val);
  181. }
  182.  
  183. /* newclosure - allocate and initialize a new closure */
  184. LVAL newclosure(name,type,env,fenv)
  185.   LVAL name,type,env,fenv;
  186. {
  187.     LVAL val;
  188.     val = newvector(CLOSIZE);
  189.     val->n_type = CLOSURE;
  190.     setname(val,name);
  191.     settype(val,type);
  192.     setenv(val,env);
  193.     setfenv(val,fenv);
  194.     return (val);
  195. }
  196.  
  197. /* newstruct - allocate and initialize a new structure node */
  198. LVAL newstruct(type,size)
  199.   LVAL type; int size;
  200. {
  201.     LVAL val;
  202.     val = newvector(size+1);
  203.     val->n_type = STRUCT;
  204.     setelement(val,0,type);
  205.     return (val);
  206. }
  207.  
  208. /* newvector - allocate and initialize a new vector node */
  209. LVAL newvector(size)
  210.   int size;
  211. {
  212.     LVAL vect;
  213.     int bsize;
  214.     xlsave1(vect);
  215.     vect = newnode(VECTOR);
  216.     vect->n_vsize = 0;
  217.     if (bsize = size * sizeof(LVAL)) {
  218.     if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
  219.         findmem();
  220.         if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
  221.         xlfail("insufficient vector space");
  222.     }
  223.     vect->n_vsize = size;
  224.     total += (long) bsize;
  225.     }
  226.     xlpop();
  227.     return (vect);
  228. }
  229.  
  230. /* newnode - allocate a new node */
  231. LOCAL LVAL newnode(type)
  232.   int type;
  233. {
  234.     LVAL nnode;
  235.  
  236.     /* get a free node */
  237.     if ((nnode = fnodes) == NIL) {
  238.     findmem();
  239.     if ((nnode = fnodes) == NIL)
  240.         xlabort("insufficient node space");
  241.     }
  242.  
  243.     /* unlink the node from the free list */
  244.     fnodes = cdr(nnode);
  245.     nfree -= 1L;
  246.  
  247.     /* initialize the new node */
  248.     nnode->n_type = type;
  249.     rplacd(nnode,NIL);
  250.  
  251.     /* return the new node */
  252.     return (nnode);
  253. }
  254.  
  255. /* stralloc - allocate memory for a string adding a byte for the terminator */
  256. LOCAL unsigned char *stralloc(size)
  257.   int size;
  258. {
  259.     unsigned char *sptr;
  260.  
  261.     /* allocate memory for the string copy */
  262.     if ((sptr = (unsigned char *)malloc(size)) == NULL) {
  263.     gc();  
  264.     if ((sptr = (unsigned char *)malloc(size)) == NULL)
  265.         xlfail("insufficient string space");
  266.     }
  267.     total += (long)size;
  268.  
  269.     /* return the new string memory */
  270.     return (sptr);
  271. }
  272.  
  273. /* findmem - find more memory by collecting then expanding */
  274. LOCAL findmem()
  275. {
  276.     gc();
  277.     if (nfree < (long)anodes)
  278.     addseg();
  279. }
  280.  
  281. /* gc - garbage collect (only called here and in xlimage.c) */
  282. gc()
  283. {
  284.     register LVAL **p,*ap,tmp;
  285.     char buf[STRMAX+1];
  286.     LVAL *newfp,fun;
  287.  
  288.     /* print the start of the gc message */
  289.     if (s_gcflag && getvalue(s_gcflag)) {
  290.     sprintf(buf,"[ gc: total %ld, ",nnodes);
  291.     stdputstr(buf);
  292.     }
  293.  
  294.     /* mark the obarray, the argument list and the current environment */
  295.     if (obarray)
  296.     mark(obarray);
  297.     if (xlenv)
  298.     mark(xlenv);
  299.     if (xlfenv)
  300.     mark(xlfenv);
  301.     if (xldenv)
  302.     mark(xldenv);
  303.  
  304.     /* mark the evaluation stack */
  305.     for (p = xlstack; p < xlstktop; ++p)
  306.     if (tmp = **p)
  307.         mark(tmp);
  308.  
  309.     /* mark the argument stack */
  310.     for (ap = xlargstkbase; ap < xlsp; ++ap)
  311.     if (tmp = *ap)
  312.         mark(tmp);
  313.  
  314.     /* sweep memory collecting all unmarked nodes */
  315.     sweep();
  316.  
  317.     /* count the gc call */
  318.     ++gccalls;
  319.  
  320.     /* call the *gc-hook* if necessary */
  321.     if (s_gchook && (fun = getvalue(s_gchook))) {
  322.     newfp = xlsp;
  323.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  324.     pusharg(fun);
  325.     pusharg(cvfixnum((FIXTYPE)2));
  326.     pusharg(cvfixnum((FIXTYPE)nnodes));
  327.     pusharg(cvfixnum((FIXTYPE)nfree));
  328.     xlfp = newfp;
  329.     xlapply(2);
  330.     }
  331.  
  332.     /* print the end of the gc message */
  333.     if (s_gcflag && getvalue(s_gcflag)) {
  334.     sprintf(buf,"%ld free ]\n",nfree);
  335.     stdputstr(buf);
  336.     }
  337. }
  338.  
  339. /* mark - mark all accessible nodes */
  340. LOCAL mark(ptr)
  341.   LVAL ptr;
  342. {
  343.     register LVAL this,prev,tmp;
  344.     int type,i,n;
  345.  
  346.     /* initialize */
  347.     prev = NIL;
  348.     this = ptr;
  349.  
  350.     /* mark this list */
  351.     for (;;) {
  352.  
  353.     /* descend as far as we can */
  354.     while (!(this->n_flags & MARK))
  355.  
  356.         /* check cons and unnamed stream nodes */
  357.         if ((type = ntype(this)) == CONS || type == USTREAM) {
  358.         if (tmp = car(this)) {
  359.             this->n_flags |= MARK|LEFT;
  360.             rplaca(this,prev);
  361.         }
  362.         else if (tmp = cdr(this)) {
  363.             this->n_flags |= MARK;
  364.             rplacd(this,prev);
  365.         }
  366.         else {                /* both sides nil */
  367.             this->n_flags |= MARK;
  368.             break;
  369.         }
  370.         prev = this;            /* step down the branch */
  371.         this = tmp;
  372.         }
  373.  
  374.         /* mark other node types */
  375.         else {
  376.         this->n_flags |= MARK;
  377.         switch (type) {
  378.         case SYMBOL:
  379.         case OBJECT:
  380.         case VECTOR:
  381.         case CLOSURE:
  382.         case STRUCT:
  383.             for (i = 0, n = getsize(this); --n >= 0; ++i)
  384.             if (tmp = getelement(this,i))
  385.                 mark(tmp);
  386.             break;
  387.         }
  388.         break;
  389.         }
  390.  
  391.     /* backup to a point where we can continue descending */
  392.     for (